home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume11 / test.el / part01 next >
Encoding:
Text File  |  1987-09-08  |  58.0 KB  |  2,002 lines
  1. Path: uunet!rs
  2. From: rs@uunet.UU.NET (Rich Salz)
  3. Newsgroups: comp.sources.unix
  4. Subject: v11i036:  Test system for GNU Emacs, Part01/03
  5. Message-ID: <1501@uunet.UU.NET>
  6. Date: 10 Sep 87 03:53:05 GMT
  7. Organization: UUNET Communications Services, Arlington, VA
  8. Lines: 1991
  9. Approved: rs@uunet.UU.NET
  10.  
  11. Submitted-by: "Mark A. Ardis" <maa@sei.cmu.edu>
  12. Posting-number: Volume 11, Issue 36
  13. Archive-name: test.el/Part01
  14.  
  15. I am sending you (in 3 parts) a package for GNU Emacs called
  16. "test".  It is designed to help authors of GNU Emacs Lisp packages
  17. test their products.  Some of the features of "test" provide
  18. assistance in constructing tests and testscripts.  Other features
  19. assist in the analysis of the effectiveness of testing.
  20.  
  21. Unfortunately, this package has not been adequately tested itself.  It
  22. is the product of a semester-long project at Wang Institute.  Since
  23. the MSE program is being discontinued, we are forced to distribute
  24. this package prematurely, lest it be lost.  As the instructor of the
  25. course I will be glad to collect comments, suggestions, bug reports,
  26. etc. at my new address:
  27.  
  28. Mark A. Ardis
  29. Software Engineering Institute
  30. 4500 Fifth Avenue
  31. Pittsburgh, PA 15213
  32. (412) 268-7636
  33. maa@sei.cmu.edu (ARPANET)
  34.  
  35.  
  36. #! /bin/sh
  37. # This is a shell archive, meaning:
  38. # 1. Remove everything above the #! /bin/sh line.
  39. # 2. Save the resulting text in a file.
  40. # 3. Execute the file with /bin/sh (not csh) to create:
  41. #    tst-display.el
  42. #    tst-equal.el
  43. #    tst-inequal.el
  44. #    tst-instrument.el
  45. # This archive created: Thu Aug  6 17:02:17 1987
  46. export PATH; PATH=/bin:/usr/bin:$PATH
  47. echo shar: "extracting 'tst-display.el'" '(12443 characters)'
  48. if test -f 'tst-display.el'
  49. then
  50.     echo shar: "will not over-write existing file 'tst-display.el'"
  51. else
  52. sed 's/^X//' << \SHAR_EOF > 'tst-display.el'
  53. X;;; display.el - GnuTest Display Package
  54. X;;; Copyright (c) 1987 Wang Institute of Graduate Studies
  55. X;;; Andy Bliven <bliven@wanginst>
  56. X
  57. X(provide 'tst-display)
  58. X(require 'tst-annotate)
  59. X
  60. X;;; ----------------------------------------------------------------------
  61. X;;; Public Variables--
  62. X  
  63. X(defconst tst-display-window-width 10
  64. X  "*  Width of each display window, in columns")
  65. X  
  66. X(defconst tst-display-attributes (list 'zero 'constant)
  67. X  "*  List of attributes to be displayed in batch mode.")
  68. X
  69. X;;; ----------------------------------------------------------------------
  70. X;;; Private Variables--
  71. X  
  72. X(defvar tst-display-buffer-alist nil
  73. X  "An alist of attribute names and buffer objects")
  74. X  
  75. X(defvar tst-display-lisp-buffer nil
  76. X  "The buffer of emacs lisp code that has been annotated.")
  77. X  
  78. X(defvar tst-display-lisp-window nil
  79. X  "The window containing emacs lisp code.")
  80. X  
  81. X(defvar tst-display-mode-map nil
  82. X  "Keymap for GnuTest Display major mode.")
  83. X(or tst-display-mode-map
  84. X    (progn
  85. X      (setq tst-display-mode-map (make-keymap))
  86. X      (suppress-keymap tst-display-mode-map) ; requires full keymap, not sparse
  87. X                    ; key definitions
  88. X      (define-key tst-display-mode-map "\C-n"    'tst-display-next-line)
  89. X      (define-key tst-display-mode-map "\C-p"    'tst-display-previous-line)
  90. X      (define-key tst-display-mode-map "\C-v"    'tst-display-scroll-up)
  91. X      (define-key tst-display-mode-map "\M-v"     'tst-display-scroll-down)
  92. X      (define-key tst-display-mode-map "\C-c\C-h" 'tst-display-mode-help)
  93. X      (define-key tst-display-mode-map "\C-cc"   'tst-display-constant)
  94. X      (define-key tst-display-mode-map "\C-cl"   'tst-display-redraw)
  95. X      (define-key tst-display-mode-map "\C-cn"   'tst-display-next)
  96. X      (define-key tst-display-mode-map "\C-cp"   'tst-display-previous)
  97. X      (define-key tst-display-mode-map "\C-cq"   'tst-display-mode-exit)
  98. X      (define-key tst-display-mode-map "\C-cz"   'tst-display-zero)
  99. X      )
  100. X    )
  101. X  
  102. X(defvar tst-display-window-alist nil
  103. X  "An alist of attribute names and window objects")
  104. X
  105. X(defvar tst-batch-results "tst-batch-results"
  106. X  "* a kluge")
  107. X
  108. X(defvar tst-display-saved-variables nil
  109. X  "The property list of this variable contains values of all variables
  110. X   saved on entry to tst-display-mode.")
  111. X  
  112. X
  113. X
  114. X;;; ----------------------------------------------------------------------
  115. X;;; Public Functions--
  116. X  
  117. X(defun tst-display-batch (&optional lisp-buffer)
  118. X  "   Batch mode execution of the annotation display package.  Writes the
  119. X   summary reports 'zero' and 'constant' generated by the tst-analyze
  120. X   package into a 'compilation' style buffer named '*compilation*'.  If
  121. X   called interactively this is available for viewing with the '^X`' key,
  122. X   otherwise it is saved to the file named in tst-batch-results.  If
  123. X   LISP-BUFFER is not specified, current-buffer is used instead as the
  124. X   label on each line of the report."
  125. X  (interactive)
  126. X                    ; body
  127. X  (let ((lisp-buffer (or lisp-buffer (current-buffer)))
  128. X    (save-window (selected-window)))
  129. X    (pop-to-buffer "*compilation*")
  130. X    (erase-buffer)
  131. X    (insert "# GnuTest analysis of " (buffer-name lisp-buffer) "\n"
  132. X        "#   (lines which were never evaluated during tests or returned\n"
  133. X        "#    the same value every time they were evaluated.)\n")
  134. X    (mapcar '(lambda (line)
  135. X           (insert (tst-display-batch-string lisp-buffer
  136. X                         line
  137. X                         'zero
  138. X                         'constant)))
  139. X        (tst-ann-get-lines))
  140. X    (if (interactive-p)
  141. X    (progn
  142. X      (goto-char (point-min))    ; top of results buffer
  143. X      (switch-to-buffer "*compilation*")
  144. X      (select-window save-window)    ; go back to original window
  145. X      )
  146. X      ;; else
  147. X      (write-file tst-batch-results) ; write buffer to disk
  148. X      )
  149. X    )
  150. X  )
  151. X  
  152. X(defun tst-display-mode ()
  153. X  "*  Major mode for displaying GnuTest annotation with associated
  154. X   emacs-lisp code buffer.  Precondition:  tst-instrument and tst-analyze
  155. X   have already been evaluated for this buffer.
  156. X   C-n     tst-display-next-line        
  157. X   C-p     tst-display-previous-line    
  158. X   C-v     tst-display-scroll-up        
  159. X   M-v     tst-display-scroll-down      
  160. X   C-c C-h tst-display-mode-help
  161. X   C-c c   tst-display-constant
  162. X   C-c l   tst-display-redraw           
  163. X   C-c n   tst-display-next
  164. X   C-c p   tst-display-previous
  165. X   C-c q   tst-display-mode-exit
  166. X   C-c z   tst-display-zero
  167. X  "
  168. X  (interactive)
  169. X                    ; body
  170. X  (if (equal major-mode 'tst-display-mode)
  171. X      (tst-display-mode-exit)
  172. X    (put 'tst-display-saved-variables 'mode-name mode-name)
  173. X    (put 'tst-display-saved-variables 'major-mode major-mode)
  174. X    (put 'tst-display-saved-variables 'local-map (current-local-map))
  175. X    (put 'tst-display-saved-variables 'buffer-read-only buffer-read-only)
  176. X    (put 'tst-display-saved-variables 'truncate-lines truncate-lines)
  177. X    (setq mode-name "Test Display")
  178. X    (setq major-mode 'tst-display-mode)
  179. X    (use-local-map tst-display-mode-map) ; setup keymap
  180. X    (set-buffer-modified-p (buffer-modified-p))    ; Idiom to reset modeline.
  181. X    (setq truncate-lines t)
  182. X    (setq buffer-read-only t)
  183. X    (setq tst-display-lisp-buffer (current-buffer))
  184. X    (setq tst-display-lisp-window (selected-window))
  185. X    )
  186. X  )
  187. X
  188. X(defun tst-display-mode-help ()
  189. X  "Help screen for Test Display Mode."
  190. X  (interactive)
  191. X  (with-output-to-temp-buffer "*Help*"
  192. X    (princ (car (cdr (cdr (symbol-function 'tst-display-mode)))))
  193. X    )
  194. X  )
  195. X  
  196. X(defun tst-display-mode-exit ()
  197. X  "exit Test Display Mode"
  198. X  (interactive)
  199. X                    ; close annotation windows
  200. X  (let ((buflist (mapcar 'cdr tst-display-buffer-alist)))
  201. X    (mapcar '(lambda (buf)
  202. X           (and (get-buffer-window buf)
  203. X            (delete-window (get-buffer-window buf))))
  204. X        buflist)
  205. X    )                    ; let
  206. X                    ; clean up global variables
  207. X  (setq tst-display-buffer-alist nil)
  208. X                    ; restore old state
  209. X  (setq mode-name (get 'tst-display-saved-variables 'mode-name))
  210. X  (setq major-mode (get 'tst-display-saved-variables 'major-mode))
  211. X  (use-local-map (get 'tst-display-saved-variables 'local-map))
  212. X  (set-buffer-modified-p (buffer-modified-p))    ; Idiom to reset modeline.
  213. X  (setq truncate-lines (get 'tst-display-saved-variables 'truncate-lines))
  214. X  (setq buffer-read-only (get 'tst-display-saved-variables 'buffer-read-only))
  215. X  )
  216. X  
  217. X(defun tst-display-constant ()
  218. X  "Display values which never changed during test runs."
  219. X  (interactive)
  220. X                    ;body
  221. X  (tst-display-open-buffer 'constant)
  222. X  (tst-display-open-window 'constant)
  223. X  )
  224. X  
  225. X(defun tst-display-zero ()
  226. X  "Display values which were never evaluated during test runs."
  227. X  (interactive)
  228. X                    ;body
  229. X  (tst-display-open-buffer 'zero)
  230. X  (tst-display-open-window 'zero)
  231. X  )
  232. X  
  233. X(defun tst-display-next-line (&optional lines)
  234. X  "Move point down one line in lisp buffer and any annotation buffers."
  235. X  (interactive "p")
  236. X  (let ((nlines (or lines 1))
  237. X    (savewindow (selected-window))
  238. X    (buflist (mapcar 'cdr tst-display-buffer-alist)))
  239. X    (mapcar '(lambda (buf)
  240. X           (let ((win (get-buffer-window buf)))
  241. X         (if win
  242. X             (progn (select-window win)
  243. X                (next-line nlines)))))
  244. X        (cons tst-display-lisp-buffer buflist)
  245. X        )
  246. X    (select-window savewindow)
  247. X    )
  248. X  )
  249. X
  250. X(defun tst-display-previous-line (&optional lines)
  251. X  "Move point up LINES lines (1 if nil) in lisp buffer and any annotation
  252. X   buffers."
  253. X  (interactive "p")
  254. X  (let ((nlines (- (or lines 1))))
  255. X    (tst-display-next-line nlines)
  256. X    )
  257. X  )
  258. X  
  259. X(defun tst-display-scroll-down (&optional lines)
  260. X  "Scroll down LINES lines in lisp buffer and any annotation buffers."
  261. X  (interactive "P")
  262. X  (let ((nlines (and lines (prefix-numeric-value lines)))
  263. X    (savewindow (selected-window))
  264. X    (buflist (mapcar 'cdr tst-display-buffer-alist)))
  265. X    (mapcar '(lambda (buf)
  266. X           (let ((win (get-buffer-window buf)))
  267. X         (if win
  268. X             (progn (select-window win)
  269. X                (scroll-down nlines)))))
  270. X        (cons tst-display-lisp-buffer buflist)
  271. X        )
  272. X    (select-window savewindow)
  273. X    )
  274. X  )
  275. X
  276. X(defun tst-display-scroll-up (&optional lines)
  277. X  "Scroll up LINES lines in lisp buffer and any annotation buffers."
  278. X  (interactive "P")
  279. X  (let ((nlines (and lines (- (prefix-numeric-value lines))))
  280. X    (savewindow (selected-window))
  281. X    (buflist (mapcar 'cdr tst-display-buffer-alist)))
  282. X    (mapcar '(lambda (buf)
  283. X           (let ((win (get-buffer-window buf)))
  284. X         (if win
  285. X             (progn (select-window win)
  286. X                (scroll-up nlines)))))
  287. X        (cons tst-display-lisp-buffer buflist)
  288. X        )
  289. X    (select-window savewindow)
  290. X    )
  291. X  )
  292. X  
  293. X(defun tst-display-open-buffer (attribute)
  294. X  "Create a buffer named *display-ATTRIBUTE*.  Fill it with values from
  295. X   the annotation database."
  296. X  (interactive "Sattribute name: ")
  297. X  (let ((newbuffer nil)
  298. X    (bufname (concat "*tst-"
  299. X             (prin1-to-string attribute)
  300. X             "*")))
  301. X    (save-excursion
  302. X                    ; get buffer
  303. X      (setq newbuffer (get-buffer-create bufname))
  304. X      (setq tst-display-buffer-alist
  305. X        (tst-alist-put tst-display-buffer-alist
  306. X               attribute
  307. X               newbuffer))
  308. X                    ; fill buffer
  309. X      (set-buffer newbuffer)
  310. X      (let ((buffer-read-only nil))
  311. X    (setq mode-line-format (prin1-to-string attribute))
  312. X    (erase-buffer)
  313. X    (newline (tst-display-maxline))
  314. X    (mapcar '(lambda (line)
  315. X           (goto-line line)
  316. X           (insert (tst-display-get-string line attribute)))
  317. X        (tst-ann-get-lines))
  318. X                    ; setup keymap
  319. X    (use-local-map tst-display-mode-map)
  320. X    (setq truncate-lines t)
  321. X    )
  322. X      (setq buffer-read-only t)))
  323. X  )
  324. X  
  325. X(defun tst-display-save-buffer (attribute)
  326. X  "Save a buffer given ATTRIBUTE name."
  327. X  (set-buffer (tst-alist-get tst-display-buffer-alist attribute))
  328. X  (set-visited-file-name (buffer-name))
  329. X  (save-buffer)
  330. X  )
  331. X  
  332. X(defun tst-display-open-window (attribute)
  333. X  "Open a window onto an attribute."
  334. X  (interactive "Sattribute name: ")
  335. X                    ; body
  336. X  (let ((saved-line (tst-display-current-line)))
  337. X    (split-window-horizontally tst-display-window-width)
  338. X    (setq tst-display-window-alist
  339. X      (tst-alist-put tst-display-window-alist
  340. X             attribute
  341. X             (selected-window)))
  342. X    (switch-to-buffer (tst-alist-get tst-display-buffer-alist attribute))
  343. X    (other-window 1)
  344. X    (tst-display-redraw)
  345. X;    (goto-line saved-line)
  346. X;    (recenter)
  347. X;    (recenter)
  348. X    )
  349. X  )
  350. X  
  351. X(defun tst-display-close-window (attribute)
  352. X  "Close a window onto an attribute."
  353. X  (interactive "Sattribute name: ")
  354. X  
  355. X  (let ((win (tst-alist-get tst-display-window-alist attribute)))
  356. X    (and win
  357. X    (progn (delete-window win)
  358. X           (tst-alist-rem tst-display-window-alist attribute)))
  359. X    )
  360. X  )
  361. X  
  362. X(defun tst-display-redraw (&optional line)
  363. X  "Redraw all windows after moving to same line in display-windows
  364. X   as in current window."
  365. X  (interactive)
  366. X  (let ((curline (or line (tst-display-current-line)))
  367. X    (savewindow (selected-window))
  368. X    (buflist (mapcar 'cdr tst-display-buffer-alist)))
  369. X    (mapcar '(lambda (buf)
  370. X           (let ((win (get-buffer-window buf)))
  371. X         (select-window win)
  372. X         (goto-line curline)
  373. X         (recenter)))
  374. X        buflist)
  375. X    (select-window savewindow)
  376. X    (goto-line curline)
  377. X    (recenter)
  378. X    )
  379. X  )
  380. X  
  381. X
  382. X;;; ----------------------------------------------------------------------
  383. X;;; Private Functions--
  384. X
  385. X(defun tst-display-batch-string (buffer line &rest attrlist)
  386. X  "Returns a string 'buffer-name:line-number:values\n'."
  387. X  (let (value string)
  388. X    (setq string (apply 'concat
  389. X            (mapcar '(lambda (attr)
  390. X                   (tst-display-get-string line attr))
  391. X                attrlist))
  392. X      )
  393. X    (if (equal "" string)
  394. X    ""
  395. X      (concat (buffer-name buffer)
  396. X          ":"
  397. X          (prin1-to-string line)
  398. X          "==  "
  399. X          string
  400. X          "\n"))
  401. X    )
  402. X  )
  403. X
  404. X(defun tst-display-get-string (line attribute)
  405. X  "   return a string representation of the value <LINE ATTRIBUTE> from
  406. X   the annotation database."
  407. X                    ; body
  408. X  (let ((value (tst-ann-get line attribute)))
  409. X    (cond
  410. X     ((null value) "")
  411. X     ((and (listp value)
  412. X       (= 1 (length value))) (prin1-to-string (car value)))
  413. X     (t (prin1-to-string value))
  414. X     )
  415. X    )
  416. X  )
  417. X  
  418. X(defun tst-display-maxline ()
  419. X  "Returns number of lines in lisp-buffer"
  420. X  (save-excursion
  421. X   (set-buffer tst-display-lisp-buffer)
  422. X   (count-lines (point-min) (point-max))
  423. X   )
  424. X  )
  425. X  
  426. X(defun tst-display-current-line ()
  427. X  "Returns current line number"
  428. X  (1+ (count-lines (point-min) (point)))
  429. X  )
  430. X  
  431. X(defun tst-display-test-init ()
  432. X  "Test driver for package functions."
  433. X  (interactive)
  434. X  
  435. X  (let ((attr-list tst-display-attributes)
  436. X    (line-list nil)
  437. X    (line 1)
  438. X    )
  439. X                    ; Create a database (cheap)
  440. X    (tst-ann-set-db nil)
  441. X    (goto-char (point-min))
  442. X    (while (not (eobp))
  443. X      (tst-ann-put line 'constant (list line line line))
  444. X      (tst-ann-put line 'zero 'NEVER->>)
  445. X      (next-line 1)
  446. X      (setq line (1+ line))
  447. X      )
  448. X    )
  449. X  )
  450. SHAR_EOF
  451. if test 12443 -ne "`wc -c < 'tst-display.el'`"
  452. then
  453.     echo shar: "error transmitting 'tst-display.el'" '(should have been 12443 characters)'
  454. fi
  455. fi
  456. echo shar: "extracting 'tst-equal.el'" '(32129 characters)'
  457. if test -f 'tst-equal.el'
  458. then
  459.     echo shar: "will not over-write existing file 'tst-equal.el'"
  460. else
  461. sed 's/^X//' << \SHAR_EOF > 'tst-equal.el'
  462. X;;; tst-equal.el -- A number of definitions of equality
  463. X;;; Lorri Menard, Wang Institute of Graduate Studies
  464. X;;; Don Zaremba, Wang Institute of Graduate Studies
  465. X;;; Copyright 1987 Wang Institute of Graduate Studies
  466. X;;;
  467. X
  468. X(provide 'tst-equal)
  469. X
  470. X(defvar tst-equ-log-all-compares "t"
  471. X  "* If not nil then all comparisons are logged into the buffer
  472. X     *equal-log*."
  473. X)
  474. X
  475. X(defvar tst-equ-max-line-diffs "15"
  476. X  "* Maximum number of different lines to log when comparing
  477. X     buffer contents line-by-line. "
  478. X)
  479. X
  480. X(defvar tst-equ-state-functions '(tst-equ-session
  481. X                      tst-equ-buffers 
  482. X                      tst-equ-processes
  483. X                      tst-equ-windows)
  484. X  "* A list of functions to be executed when comparing objects
  485. X     of type state."
  486. X)
  487. X
  488. X(defvar tst-equ-buff-state-functions '(tst-equ-point 
  489. X                  tst-equ-mark
  490. X                  tst-equ-contents
  491. X                  tst-equ-modified
  492. X                  tst-equ-file 
  493. X                  tst-equ-local-vars)
  494. X  "* A list of functions to be executed when comparing objects
  495. X     of type buffer-state."
  496. X)
  497. X
  498. X(defconst tst-equ-indent 3)
  499. X
  500. X(defmacro tst-equ-level1 ()
  501. X (insert "*") (indent-to tst-equ-indent))
  502. X
  503. X(defmacro tst-equ-level2 ()
  504. X  (insert "**") (indent-to (* tst-equ-indent 2)))
  505. X
  506. X(defmacro tst-equ-level3 ()
  507. X  (insert "***") (indent-to (* tst-equ-indent 3)))
  508. X
  509. X(defmacro tst-equ-level4 ()
  510. X  (insert "****") (indent-to (* tst-equ-indent 4)))
  511. X
  512. X(defmacro tst-equ-level5 ()
  513. X  (insert "*****") (indent-to (* tst-equ-indent 5)))
  514. X
  515. X(defmacro tst-equ-level6 ()
  516. X  (insert "******") (indent-to (* tst-equ-indent 6)))
  517. X
  518. X(defmacro tst-equ-level7 ()
  519. X  (insert "*******")  (indent-to (* tst-equ-indent 7)))
  520. X
  521. X(defmacro tst-equ-level8 ()
  522. X  (insert "********")  (indent-to (* tst-equ-indent 8)))
  523. X
  524. X(defmacro tst-equ-level9 ()
  525. X  (insert "*********")  (indent-to (* tst-equ-indent 9)))
  526. X
  527. X
  528. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  529. X;   A number of equality testing functions follow. Each is of the
  530. X;   form tst-equ-state-component (state1 state2). Each compares a particular
  531. X;   component from the two states and returns t if equal, else nil.
  532. X;   As a side effect the buffer *equal-log* is updated with the results
  533. X;   of the comparison
  534. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  535. X
  536. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  537. X
  538. X(defun tst-equ-state (tst-equ-state1 tst-equ-state2 name)
  539. X  "Compares for equality the complete state of a pair of sessions.
  540. X   The two parameters STATE1 and STATE2 must be complete states
  541. X   as returned by tst-reg-capture-state. The results of the comparison
  542. X   are written into buffer *equal-log*. NAME is used to identify the test.
  543. X   Four major components are compared: session, buffers, windows, and
  544. X   processes. "
  545. X
  546. X  (interactive "XState variable 1:
  547. XXState variable 2:
  548. XsName of this test:")
  549. X
  550. X
  551. X  (let (ss-fun-vector function-name tst-equ-result tst-equ-startpoint temppoint)
  552. X
  553. X    (message "Comparing states...")
  554. X    (setq ss-fun-vector tst-equ-state-functions)
  555. X    (setq tst-equ-result t); let's be optomistic
  556. X
  557. X    ; set up the log buffer
  558. X    (get-buffer-create "*equal-log*")
  559. X    (set-buffer "*equal-log*")
  560. X    (outline-mode)
  561. X    (tst-equ-level1)
  562. X    (setq tst-equ-startpoint (point))    ;save "here"
  563. X    (insert "State comparison: " name)
  564. X    (newline)
  565. X    (newline)
  566. X
  567. X    (while ss-fun-vector
  568. X      (progn
  569. X    (setq function-name (car ss-fun-vector))
  570. X    (setq ss-fun-vector (cdr ss-fun-vector))
  571. X    (newline)
  572. X;;;    (insert "  " (prin1-to-string function-name))
  573. X    (newline)
  574. X    (if (not (funcall function-name tst-equ-state1 tst-equ-state2))
  575. X        (setq tst-equ-result nil); set return value if failed
  576. X      ); fi
  577. X    ); ngrop
  578. X      ); elihw
  579. X
  580. X    ; if we failed and a hook exist then run iot
  581. X    (if (and (not tst-equ-result) 'tst-equ-state-hook)
  582. X           (run-hooks 'tst-equ-state-hook))
  583. X
  584. X    (if (not tst-equ-result)
  585. X        (progn
  586. X          (setq temppoint (point))
  587. X          (goto-char tst-equ-startpoint)
  588. X          (insert "?")
  589. X          (goto-char (1+ temppoint))
  590. X          ); ngorp
  591. X      );fi
  592. X    (message "Comparing states... done")
  593. X    tst-equ-result
  594. X    ); tel
  595. X); nufed tst-equ-state
  596. X
  597. X(defun tst-equ-session (state1 state2)
  598. X   "Compares the session components from two states. The
  599. X   two parameters STATE1 and STATE2 must be complete states
  600. X   as returned by tst-reg-capture-state. The session components
  601. X   include: global-bound-syms. "
  602. X
  603. X   (interactive "P")
  604. X
  605. X   (let (sess1 sess2 syms1 syms2 ss-startpoint ss-gs-startpoint temppoint el1 el2)
  606. X    (message "Comparing state of sessions...")
  607. X
  608. X    (goto-char (point-max))        ; .. of output buffer
  609. X    (tst-equ-level2)
  610. X    (setq ss-startpoint (point))
  611. X    (insert "Sessions state")
  612. X    (newline)
  613. X
  614. X    (setq sess1 (cadr (assoc 'session state1)))
  615. X    (setq sess2 (cadr (assoc 'session state2)))
  616. X    
  617. X    (tst-equ-level3)
  618. X    (setq ss-gs-startpoint (point))
  619. X    (insert "Global symbols")
  620. X    (newline)
  621. X
  622. X    (setq syms1 (cadr (assoc 'global-bound-syms sess1)))
  623. X    (setq syms2 (cadr (assoc 'global-bound-syms sess2)))
  624. X    (if (not (setq tst-equ-result (equal syms1 syms2)))
  625. X        (progn
  626. X          (while (and syms1 syms2)
  627. X            (setq el1 (car syms1))
  628. X            (setq syms1 (cdr syms1))
  629. X            (setq el2 (assoc (car el1) syms2))
  630. X            ;;        (debug "nil" el1 el2)
  631. X            (if el2
  632. X                (setq syms2 (delq el2 syms2))
  633. X;;                (list 'setq syms2 (list 'delq (list 'assoc (car el1) syms2) 
  634. X;;                                        syms2))
  635. X              (progn                        ;else ..
  636. X                (indent-to (* tst-equ-indent 4))
  637. X                (insert "?")
  638. X                (insert (prin1-to-string (car el1)) " not found in second state")
  639. X                (newline)
  640. X                ); ngorp
  641. X              ); fi
  642. X            (tst-equ-diff-element el1 el2)
  643. X            ); wlihw
  644. X          (if syms1
  645. X              (progn
  646. X                (while syms1
  647. X                  (setq el1 (car syms1))
  648. X                  (setq syms1 (cdr syms1))
  649. X                  (indent-to (* tst-equ-indent 4))
  650. X                  (insert "?")
  651. X                  (insert (prin1-to-string (car el1)) " not found in second state")
  652. X                  (newline)
  653. X                  ); elihw
  654. X                ); ngorp
  655. X            ); fi
  656. X          (if syms2
  657. X              (progn
  658. X                (while syms2
  659. X                  (setq el2 (car syms2))
  660. X                  (setq syms2 (cdr syms2))
  661. X                  (indent-to (* tst-equ-indent 4))
  662. X                  (insert "?")
  663. X                  (insert (prin1-to-string (car el2)) " not found in first state")
  664. X                  (newline)
  665. X                  ); elihw
  666. X                
  667. X                );ngorp
  668. X            ); fi
  669. X                ); ngorp
  670. X            ; else .. nevermind.
  671. X            ); fi
  672. X    (if (not tst-equ-result)
  673. X        (progn
  674. X          (setq temppoint (point))
  675. X          (goto-char ss-startpoint)
  676. X          (insert "?")
  677. X; if ever there are more things in a session, these two lines need to
  678. X;   be separate.
  679. X          (goto-char ss-gs-startpoint)
  680. X          (insert "?")
  681. X;
  682. X          (goto-char (1+ temppoint))
  683. X          );
  684. X      ); fi
  685. X
  686. X     tst-equ-result
  687. X     ); tel
  688. X)
  689. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  690. X
  691. X(defun tst-equ-buffers (tst-equ-buffers1 tst-equ-buffers2)
  692. X  "Compares the buffers components from two states. The
  693. X   two parameters STATE1 and STATE2 must be complete states
  694. X   as returned by tst-reg-capture-state. Compares each buffer for
  695. X   equality with its corresponding buffer (by name) in the other
  696. X   state. tst-equ-buffer-state is called for each pair of buffers. "
  697. X
  698. X  (interactive "P")
  699. X                    ; Local Variables
  700. X  (let (buffers1 buffers2 buff1 buff-name buff2 tst-equ-result buf1names 
  701. X                  bs-startpoint temppoint)  
  702. X
  703. X    (message "Comparing state of buffers...")
  704. X    (setq tst-equ-result t)
  705. X    (setq buffers1 (cadr (assoc 'buffers tst-equ-buffers1))); get the first value
  706. X    (setq buffers2 (cadr (assoc 'buffers tst-equ-buffers2))); get the second value
  707. X
  708. X    ; set up the log buffer
  709. X    (goto-char (point-max))
  710. X    (tst-equ-level2)
  711. X    (setq bs-startpoint (point))
  712. X    (insert "Buffers state")
  713. X    (newline)
  714. X
  715. X    (while buffers1
  716. X      (progn
  717. X        (setq buff1 (car buffers1))
  718. X        (setq buffers1 (cdr buffers1))
  719. X    ; get the name of the 1st buffer and use it to find the second
  720. X        (setq buff-name (cadr (assoc 'buf-state-name buff1)))
  721. X        (setq buf1names (cons buff-name buf1names))
  722. X    
  723. X    ; create a log entry for this buffer
  724. X
  725. X    ; now locate the second buffer
  726. X    (setq buff2 (tst-equ-find-buffer-with-name tst-equ-buffers2 buff-name))
  727. X    (if (not buff2)
  728. X        (progn
  729. X          (newline)
  730. X          (indent-to (* tst-equ-indent 2))
  731. X          (insert "?")
  732. X          (insert buff-name " not found in second state")
  733. X          (newline)
  734. X          (setq tst-equ-result nil)
  735. X          ); ngorp
  736. X      ; else
  737. X        (progn
  738. X          ; now compare them and set tst-equ-result
  739. X          (if (not (tst-equ-buffer-state buff1 buff2))
  740. X                (setq tst-equ-result nil)
  741. X          ) ; fi 
  742. X          ) ; ngorp
  743. X        ); fi
  744. X
  745. X    ); ngrop
  746. X      ); elihw
  747. X;;; now that we have checked for everything from the first state,
  748. X;;;  want to see if there are any buffers in the second state that are
  749. X;;; not in the first one.   Remember the list "buf1names" that was built
  750. X;;; during the first while loop?  Well, we'll member this list instead
  751. X;;; of "tst-equ-find-buffer-with-name"ing it, because this seems more efficient.
  752. X
  753. X    (while buffers2
  754. X      (progn
  755. X        (setq buff2 (car buffers2))
  756. X        (setq buffers2 (cdr buffers2))
  757. X
  758. X        (setq buff-name (cadr (assoc 'buf-state-name buff2)))
  759. X        (if (not (member buff-name buf1names))
  760. X            (progn
  761. X              (newline)
  762. X              (indent-to (* tst-equ-indent 4))
  763. X              (insert "?")
  764. X              (insert buff-name " not found in first state")
  765. X              (newline)
  766. X              (setq tst-equ-result nil)
  767. X              ); ngorp
  768. X          ); fi
  769. X        ); ngorp
  770. X      ); elihw
  771. X              
  772. X    ; if we failed and a hook exist then run it
  773. X    (if (and (not tst-equ-result) 'tst-equ-buffers-hook)
  774. X           (run-hooks 'tst-equ-buffers-hook))
  775. X
  776. X    (if (not tst-equ-result)
  777. X        (progn
  778. X          (setq temppoint (point))
  779. X          (goto-char bs-startpoint)
  780. X          (insert "?")
  781. X          (goto-char (1+ temppoint))
  782. X          ); nprog
  783. X      ); fi
  784. X
  785. X    tst-equ-result
  786. X  ) ; let
  787. X) ; defun tst-equ-buffers
  788. X
  789. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  790. X
  791. X(defun tst-equ-windows (tst-equ-windows1 tst-equ-windows2)
  792. X   "Compares the window components from two states. The
  793. X   two parameters STATE1 and STATE2 must be complete states
  794. X   as returned by tst-reg-capture-state."
  795. X
  796. X  (interactive "P")
  797. X                    ; Local Variables
  798. X  (let (window1 window2 tst-equ-result start-point saved-point) 
  799. X
  800. X    (message "Comparing state of windows ...")
  801. X
  802. X    (setq window1 (cadr (assoc 'windows tst-equ-windows1)))
  803. X    (setq window2 (cadr (assoc 'windows tst-equ-windows2)))
  804. X    (setq tst-equ-result t)
  805. X
  806. X    (tst-equ-level2)
  807. X    (setq start-point (point))
  808. X    (insert "Window state")
  809. X    (newline)
  810. X
  811. X    (setq tst-equ-result (tst-equ-wstates window1 window2 ))
  812. X
  813. X    ; if we failed and a hook exist then run iot
  814. X    (if (and (not tst-equ-result) 'tst-equ-windows-hook)
  815. X           (run-hooks 'tst-equ-windows-hook))
  816. X
  817. X    ; if we still fail the out a ?
  818. X    (if (not tst-equ-result)
  819. X    (progn
  820. X      (setq saved-point (point))
  821. X      (goto-char start-point)
  822. X      (insert "?")
  823. X      (goto-char (1+ saved-point))
  824. X      ); ngorp
  825. X      ); if
  826. X
  827. X   tst-equ-result
  828. X    ) ; let
  829. X); defun
  830. X
  831. X(defun tst-equ-wstates (wstate1 wstate2)
  832. X "Check the equality of two windows"
  833. X 
  834. X (let (sibling leftc-edges start-point tst-equ-result tresult obj1 obj2 assoc-list
  835. X           label-list component label childs1 childs2 cl1 cl2 cr1 cr2)
  836. X
  837. X   (setq tst-equ-result t)
  838. X
  839. X   ; check for spilt windows 
  840. X   (if (assoc 'split wstate1)
  841. X       (progn
  842. X     (setq childs1 (cadr (assoc 'children wstate1)))
  843. X     (setq childs2 (cadr (assoc 'children wstate2)))
  844. X     ; Save the children
  845. X     (setq cl1 (car childs1))
  846. X     (setq cl2 (car childs2))
  847. X     (setq cr1 (car (cdr childs1)))
  848. X     (setq cr2 (car (cdr childs2)))
  849. X
  850. X     ; Now do the comparisons
  851. X     (setq tresult (tst-equ-wstates cl1 cl2))
  852. X     (setq tst-equ-result (and tresult (tst-equ-wstates cr1 cr2)))
  853. X     ); progn
  854. X     ); if split
  855. X
  856. X   ; else not spilt so compare windows
  857. X    (progn
  858. X      ; first set up the assoc and label list
  859. X      (setq assoc-list '(window-edges window-buffer window-start window-point
  860. X                   current-window))
  861. X      (setq label-list '(edges buffer start point current))
  862. X
  863. X      ; setup *equal-log* buffer
  864. X      (newline)
  865. X      (tst-equ-level3)
  866. X      (setq start-point (point))
  867. X      (insert "window")
  868. X      (newline)
  869. X
  870. X      ; loop thru the full assoc list
  871. X      (while assoc-list
  872. X    (progn
  873. X      (setq component (car assoc-list))
  874. X      (setq assoc-list (cdr assoc-list))
  875. X      (setq label (car label-list))
  876. X      (setq label-list (cdr label-list))
  877. X
  878. X      ; now get the two objects and compare them
  879. X      (tst-equ-level4)
  880. X      (setq obj1 (cadr (assoc component wstate1)))
  881. X      (setq obj2 (cadr (assoc component wstate2)))
  882. X      (setq tresult (equal obj1 obj2))
  883. X      (if (not tresult)
  884. X          (progn
  885. X        (insert "?")
  886. X        (setq tst-equ-result nil)
  887. X        ); ngorp
  888. X        ; else
  889. X        (insert " ")
  890. X        ); if
  891. X      (insert (prin1-to-string component) ": ")
  892. X      (tst-equ-log-diff tresult obj1 obj2)
  893. X      ); progn after the while
  894. X    ); while assoc-list
  895. X
  896. X      tst-equ-result
  897. X      ); progn
  898. X   ); let
  899. X); defun
  900. X
  901. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  902. X
  903. X(defun tst-equ-processes (state1 state2)
  904. X   "Compares the process components from two states. The
  905. X   two parameters STATE1 and STATE2 must be complete states
  906. X   as returned by tst-reg-capture-state. The session components
  907. X   include: command exit-status filter name sentinel status. "
  908. X
  909. X  (interactive "P")
  910. X                    ; Local Variables
  911. X  (let (proc1 proc2 p1 p2 c1 c2 tst-equ-result proc-list component start-point
  912. X          saved-point) 
  913. X
  914. X    (message "Comparing state of processes...")
  915. X    (setq proc-list '(command exit-status filter name sentinel status))
  916. X
  917. X    (setq proc1 (cadr (assoc 'processes state1)))
  918. X    (setq proc2 (cadr (assoc 'processes state2)))
  919. X    (setq tst-equ-result t)
  920. X
  921. X    (tst-equ-level2)
  922. X    (setq start-point (point))
  923. X    (insert "Processes state")
  924. X    (newline)
  925. X
  926. X    (while proc1 
  927. X      (progn
  928. X    (setq p1 (car proc1))
  929. X    (setq proc1 (cdr proc1))
  930. X    (setq p2 (car proc2))
  931. X    (setq proc2 (cdr proc2))
  932. X
  933. X    (setq proc-list '(command exit-status filter name 
  934. X                  sentinel status process-mark))
  935. X    (newline)
  936. X    (while proc-list
  937. X      (progn
  938. X        (setq component (car proc-list))
  939. X        (setq proc-list (cdr proc-list))
  940. X        (setq c1 (cadr (assoc component p1)))
  941. X        (setq c2 (cadr (assoc component p2)))
  942. X        (setq cresult (equal c1 c2))
  943. X
  944. X        (tst-equ-level3)
  945. X        (if (not cresult)
  946. X        (progn
  947. X          (insert "?")
  948. X          (setq tst-equ-result nil)
  949. X          ); ngorp
  950. X          ; else
  951. X             (insert " ")
  952. X          ); fi
  953. X        (insert (prin1-to-string component) ": ")
  954. X        (tst-equ-log-diff cresult c1 c2)
  955. X        ); ngorp
  956. X      ); elihw
  957. X
  958. X
  959. X    ); ngorp
  960. X      ); while proc1
  961. X
  962. X    ; if we failed and a hook exist then run iot
  963. X    (if (and (not tst-equ-result) 'tst-equ-processes-hook)
  964. X           (run-hooks 'tst-equ-processes-hook))
  965. X 
  966. X    (if (not tst-equ-result)
  967. X    (progn
  968. X      (setq saved-point (point))
  969. X      (goto-char start-point)
  970. X      (insert "?")
  971. X      (goto-char (1+ saved-point))
  972. X      ); ngorp
  973. X      ); fi
  974. X    tst-equ-result
  975. X  ); tel
  976. X); nufed
  977. X
  978. X
  979. X(defun tst-equ-buffer-state (buff-state1 buff-state2)
  980. X   "Compares two buffers for equality. The two parameters 
  981. X    BUFFER1 and BUFFER2 must be buffer states as returned
  982. X    by tst-equ-find-buffer. The following components are
  983. X    compared by default: point mark contents file local-variables.
  984. X    This can be modified by changing the elemetns in the variable
  985. X    tst-equ-buff-state-functions. "
  986. X
  987. X  (interactive "P")
  988. X
  989. X; Variables
  990. X
  991. X  (let (bs-fun-vector function-name tst-equ-result saved-beg msg
  992. X              fname
  993. X              saved-end tst-equ-buffer-state-startpoint)
  994. X    (get-buffer-create "*equal-log*")
  995. X    (set-buffer "*equal-log*")
  996. X    (outline-mode)
  997. X    (goto-char (point-max))
  998. X
  999. X    (newline)
  1000. X    (tst-equ-level2)
  1001. X    (setq tst-equ-buffer-state-startpoint (point))
  1002. X    (insert "Comparison of buffers named: "  )
  1003. X    (insert (cadr (assoc 'buf-state-name buff-state1)))
  1004. X    (newline)
  1005. X
  1006. X    (setq msg (concat "Comparing state of buffer " 
  1007. X              (cadr (assoc 'buf-state-name buff-state1))))
  1008. X    (message msg)
  1009. X
  1010. X  (setq bs-fun-vector tst-equ-buff-state-functions)
  1011. X  (setq tst-equ-result t) ; let's be optomistic
  1012. X
  1013. X  (while bs-fun-vector
  1014. X    (progn
  1015. X      (setq function-name (car bs-fun-vector))
  1016. X      (setq bs-fun-vector (cdr bs-fun-vector))
  1017. X
  1018. X      (tst-equ-level3)
  1019. X      (setq saved-beg (point))
  1020. X      (setq fname (prin1-to-string function-name))
  1021. X      (setq fname (substring fname (match-end 
  1022. X                 (string-match "tst-equ-" fname)) nil))
  1023. X      (insert fname ": ")
  1024. X;      (newline)
  1025. X      (if (not (funcall function-name buff-state1 buff-state2))
  1026. X          (progn
  1027. X            (setq tst-equ-result nil)   ; set return value if failed
  1028. X            (setq saved-end (point))
  1029. X            (goto-char saved-beg)
  1030. X            (insert "?")
  1031. X            (goto-char (1+ saved-end))
  1032. X
  1033. X            ); ngorp
  1034. X        ); fi
  1035. X
  1036. X      ); progn
  1037. X    ); while
  1038. X  (if (not tst-equ-result)
  1039. X      (progn
  1040. X        (setq temppoint (point))
  1041. X        (goto-char tst-equ-buffer-state-startpoint)
  1042. X        (insert "?")
  1043. X        (goto-char (1+ temppoint))
  1044. X        ); ngorp
  1045. X    ); fi
  1046. X       tst-equ-result
  1047. X  ) ; let
  1048. X
  1049. X) ; defun tst-equ-buffer-state
  1050. X
  1051. X
  1052. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1053. X
  1054. X(defun tst-equ-contents (buff-state1 buff-state2)
  1055. X  "Compares the contents component from two buffer states. "
  1056. X
  1057. X  (interactive "P")
  1058. X                    ; Local Variables
  1059. X  (let (tst-equ-contents1 tst-equ-contents2 tst-equ-result) 
  1060. X    
  1061. X    (setq tst-equ-contents1 (cadr (assoc 'buf-state-contents buff-state1)))
  1062. X    (setq tst-equ-contents2 (cadr (assoc 'buf-state-contents buff-state2)))
  1063. X    (setq tst-equ-result (string-equal tst-equ-contents1 tst-equ-contents2))
  1064. X
  1065. X    ; if a hook exist and we failed the compare then run the hook ..
  1066. X    (if (and (not tst-equ-result) 'tst-equ-contents-hook)
  1067. X           (run-hooks 'tst-equ-contents-hook))
  1068. X
  1069. X    (if (not tst-equ-result)
  1070. X        (progn
  1071. X          (indent-to (* tst-equ-indent 4))
  1072. X          (insert "contents not equal")
  1073. X          ); ngorp
  1074. X      (progn
  1075. X        (indent-to (* tst-equ-indent 4))
  1076. X        (insert "contents equal")
  1077. X        ); ngorp
  1078. X      ); fi
  1079. X    (newline)
  1080. X    tst-equ-result
  1081. X  ) ; let
  1082. X) ; defun tst-equ-contents
  1083. X
  1084. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1085. X
  1086. X(defun tst-equ-contents-region (buff-state1 buff-state2)
  1087. X  "Compares the contents component from two buffer states between
  1088. X   point and mark. "
  1089. X
  1090. X  (interactive "P")
  1091. X                    ; Local Variables
  1092. X  (let (tst-equ-contents-region1 tst-equ-contents-region2 
  1093. X                 buf-point buf-mark tst-equ-result) 
  1094. X    
  1095. X    (setq tst-equ-contents-region1 (cadr (assoc 'buf-state-contents buff-state1)))
  1096. X    (setq buf-point (cadr (assoc 'buf-state-point buff-state1)))
  1097. X    (setq buf-mark  (cadr (assoc 'buf-state-mark buff-state1)))
  1098. X    (setq tst-equ-contents-region1 
  1099. X      (substring tst-equ-contents-region1 buf-point buf-mark))
  1100. X
  1101. X    (setq tst-equ-contents-region2 (cadr (assoc 'buf-state-contents buff-state2)))
  1102. X    (setq buf-point (cadr (assoc 'buf-state-point buff-state2)))
  1103. X    (setq buf-mark  (cadr (assoc 'buf-state-mark buff-state2)))
  1104. X    (setq tst-equ-contents-region2
  1105. X      (substring tst-equ-contents-region2 buf-point buf-mark))
  1106. X
  1107. X    (setq tst-equ-result (string-equal 
  1108. X          tst-equ-contents-region1 tst-equ-contents-region2))
  1109. X
  1110. X    ; if a hook exist and we failed the compare then run the hook ..
  1111. X    (if (and (not tst-equ-result) 'tst-equ-contents-region-hook)
  1112. X           (run-hooks 'tst-equ-contents-region-hook))
  1113. X
  1114. X    (if (not tst-equ-result)
  1115. X        (progn
  1116. X          (indent-to (* tst-equ-indent 4))
  1117. X          (insert "contents not equal")
  1118. X          ); ngorp
  1119. X      (progn
  1120. X        (indent-to (* tst-equ-indent 4))
  1121. X        (insert "contents equal")
  1122. X        ); ngorp
  1123. X      ); fi
  1124. X    (newline)
  1125. X    tst-equ-result
  1126. X  ) ; let
  1127. X) ; defun tst-equ-contents-region
  1128. X
  1129. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1130. X
  1131. X(defun tst-equ-contents-line (buff-state1 buff-state2)
  1132. X  "Compares the contents component from two buffer states. Comparison
  1133. X   is performed line by line. Will run a hook named 'tst-equ-line-hook
  1134. X   that can access the strings tst-equ-line1 and tst-equ-line2. Hook is
  1135. X   called only if the comparison fails but can set tst-equ-result to t if
  1136. X   it wants."
  1137. X
  1138. X  (interactive "P")
  1139. X                    ; Local Variables
  1140. X  (let (c1 c2 tst-equ-line1 tst-equ-line2 tst-equ-result more1 more2 
  1141. X       start1 end1 start2 end2 final-result found-so-far) 
  1142. X    
  1143. X    (setq c1 (cadr (assoc 'buf-state-contents buff-state1))); get the first value
  1144. X    (setq c2 (cadr (assoc 'buf-state-contents buff-state2))); get the second value
  1145. X    (setq final-result t more1 t more2 t)
  1146. X    (setq start1 0 start2 0 found-so-far 0); starting index in strings
  1147. X
  1148. X
  1149. X    (while (and more1 more2)
  1150. X      (progn
  1151. X    (setq end1 (string-match "\n" c1 start1))
  1152. X    (if (not end1)
  1153. X        (setq more1 nil); we hit end-of-contents
  1154. X    ; else
  1155. X      (progn
  1156. X        (setq tst-equ-line1 (substring c1 start1 end1 ))
  1157. X        (setq start1 (match-end 0))
  1158. X        ); ngorp
  1159. X      ); fi
  1160. X    (setq end2 (string-match "\n" c2 start2))
  1161. X    (if (not end2)
  1162. X        (setq more2 nil); we hit end-of-contents
  1163. X    ; else
  1164. X      (progn
  1165. X        (setq tst-equ-line2 (substring c2 start2 end2 ))
  1166. X        (setq start2 (match-end 0))
  1167. X        ); ngorp
  1168. X      ); fi
  1169. X
  1170. X    ; now do the comparison if we have two lines
  1171. X    (if (and more1 more2)
  1172. X      (progn
  1173. X        (setq tst-equ-result (string-equal tst-equ-line1 tst-equ-line2))
  1174. X
  1175. X        ; if a hook exist and we failed the compare then run the hook ..
  1176. X        (if (and (not tst-equ-result) 'tst-equ-line-hook)
  1177. X          (run-hooks 'tst-equ-line-hook))
  1178. X
  1179. X        ; but test again in case hook modified result
  1180. X        (if (not tst-equ-result)
  1181. X        (progn
  1182. X          (setq final-result nil)
  1183. X          (tst-equ-log-diff-line tst-equ-line1 tst-equ-line2)
  1184. X          (setq found-so-far (+ 1 found-so-far))
  1185. X          (if (>=  found-so-far tst-equ-max-line-diffs)
  1186. X              (progn
  1187. X                ; i want to just get out of here.
  1188. X                (setq more1 nil)
  1189. X                (setq more2 nil)        ;fake 'em into leaving
  1190. X                ); ngorp
  1191. X            ); fi
  1192. X          ); ngorp
  1193. X         ); fi
  1194. X       ); ngorp
  1195. X     ); fi
  1196. X    ); ngorp
  1197. X      ); elihw
  1198. X    final-result
  1199. X  ) ; let
  1200. X) ; defun tst-equ-contents-line
  1201. X
  1202. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1203. X
  1204. X(defun tst-equ-point (buff-state1 buff-state2)
  1205. X  "Compares the point component from two buffer states. "
  1206. X
  1207. X  (interactive "P")
  1208. X                    ; Local Variables
  1209. X  (let (tst-equ-point1 tst-equ-point2 tst-equ-result) 
  1210. X    
  1211. X    (setq tst-equ-point1 (cadr (assoc 'buf-state-point buff-state1)))
  1212. X    (setq tst-equ-point2 (cadr (assoc 'buf-state-point buff-state2)))
  1213. X    (setq tst-equ-result (equal tst-equ-point1 tst-equ-point2))
  1214. X
  1215. X    ; if a hook exist and we failed the compare then run the hook ..
  1216. X    (if (and (not tst-equ-result) 'tst-equ-point-hook)
  1217. X           (run-hooks 'tst-equ-point-hook))
  1218. X    
  1219. X    (tst-equ-log-diff tst-equ-result (int-to-string tst-equ-point1) 
  1220. X              (int-to-string tst-equ-point2))
  1221. X    tst-equ-result
  1222. X  ) ; let
  1223. X) ; defun tst-equ-point
  1224. X
  1225. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1226. X
  1227. X(defun tst-equ-mark (buff-state1 buff-state2)
  1228. X  "Compares the mark component from two buffer states. "
  1229. X
  1230. X  (interactive "P")
  1231. X                    ; Local Variables
  1232. X  (let (tst-equ-mark1 tst-equ-mark2 tst-equ-result) 
  1233. X    
  1234. X    (setq tst-equ-mark1 (cadr (assoc 'buf-state-mark buff-state1)))
  1235. X    (setq tst-equ-mark2 (cadr (assoc 'buf-state-mark buff-state2)))
  1236. X    (setq tst-equ-result (equal tst-equ-mark1 tst-equ-mark2))
  1237. X
  1238. X    ; if a hook exist and we failed the compare then run the hook ..
  1239. X    (if (and (not tst-equ-result) 'tst-equ-mark-hook)
  1240. X           (run-hooks 'tst-equ-mark-hook))
  1241. X
  1242. X    (tst-equ-log-diff tst-equ-result  tst-equ-mark1 tst-equ-mark2)
  1243. X    tst-equ-result
  1244. X
  1245. X  ) ; let
  1246. X) ; defun tst-equ-mark
  1247. X
  1248. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1249. X
  1250. X(defun tst-equ-modified (buff-state1 buff-state2)
  1251. X  "Compares the modified component from two buffer states. "
  1252. X
  1253. X  (interactive "P")
  1254. X                    ; Local Variables
  1255. X  (let (tst-equ-modified1 tst-equ-modified2 tst-equ-result) 
  1256. X    
  1257. X    (setq tst-equ-modified1 (cadr (assoc 'buf-state-modified buff-state1)))
  1258. X    (setq tst-equ-modified2 (cadr (assoc 'buf-state-modified buff-state2)))
  1259. X    (setq tst-equ-result (equal tst-equ-modified1 tst-equ-modified2))
  1260. X
  1261. X    ; if a hook exist and we failed the compare then run the hook ..
  1262. X    (if (and (not tst-equ-result) 'tst-equ-modified-hook)
  1263. X           (run-hooks 'tst-equ-modified-hook))
  1264. X
  1265. X    (tst-equ-log-diff tst-equ-result  tst-equ-modified1 tst-equ-modified2)
  1266. X    tst-equ-result
  1267. X
  1268. X  ) ; let
  1269. X) ; defun tst-equ-modified
  1270. X
  1271. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1272. X
  1273. X(defun tst-equ-file (buff-state1 buff-state2)
  1274. X  "Compares the file component from two buffer states. "
  1275. X
  1276. X  (interactive "P")
  1277. X                    ; Local Variables
  1278. X  (let (tst-equ-file1 tst-equ-file2 tst-equ-result) 
  1279. X    
  1280. X    (setq tst-equ-file1 (cadr (assoc 'buf-state-file buff-state1))); get the first value
  1281. X    (setq tst-equ-file2 (cadr (assoc 'buf-state-file buff-state2))); get the second value
  1282. X    (setq tst-equ-result (equal tst-equ-file1 tst-equ-file2))
  1283. X
  1284. X    ; if a hook exist and we failed the compare then run the hook ..
  1285. X    (if (and (not tst-equ-result) 'tst-equ-file-hook)
  1286. X           (run-hooks 'tst-equ-file-hook))
  1287. X
  1288. X    (tst-equ-log-diff tst-equ-result  tst-equ-file1 tst-equ-file2)
  1289. X    tst-equ-result
  1290. X
  1291. X  ) ; let
  1292. X) ; defun tst-equ-file
  1293. X
  1294. X
  1295. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1296. X(defun tst-equ-diff-element (el1 el2)
  1297. X  " Logs differences between the two elements based on the type of 
  1298. Xelement that it is. (keymap, vector, string, list)"
  1299. X
  1300. X  (let ()
  1301. X
  1302. X    (cond  ((keymapp (cdr el1)) (tst-equ-log-keymap el1 el2))
  1303. X           ((syntax-table-p (cdr el1)) (tst-equ-log-syntable el1 el2))
  1304. X           ((stringp (cdr el1)) (tst-equ-log-string el1 el2))
  1305. X           ((atom (cdr el1)) (tst-equ-log-atom el1 el2))
  1306. X           ((arrayp (cdr el1)) (tst-equ-log-array el1 el2))
  1307. X           (t (tst-equ-log-fubar el1 el2))
  1308. X           ); dnoc
  1309. X); tel
  1310. X); defun tst-equ-diff-element
  1311. X
  1312. X(defun tst-equ-log-fubar (el1 el2)
  1313. X" Generic equal-comparer for elements of a symbol"
  1314. X
  1315. X  (let ()
  1316. X    (if (not (equal el1 el2))
  1317. X      (progn  
  1318. X;        (debug nil "in fubar" el1 el2)
  1319. X        (indent-to (* tst-equ-indent 4))
  1320. X        (insert (prin1-to-string (car el1)))
  1321. X        (if (cdr el1)
  1322. X            (insert ": "(prin1-to-string (cdr el1))  " "
  1323. X                (prin1-to-string (cdr el2)))
  1324. X          ); fi
  1325. X        (newline)
  1326. X        ); ngorp
  1327. X      ); fi
  1328. X); tel
  1329. X); defun tst-equ-log-fubar
  1330. X    
  1331. X(defun tst-equ-log-string (el1 el2)
  1332. X
  1333. X  (let ()
  1334. X
  1335. X    (if (not (equal el1 el2))
  1336. X      (progn  
  1337. X;        (debug nil "In string" (car el1))
  1338. X        (indent-to (* tst-equ-indent 4))
  1339. X        (insert (prin1-to-string (car el1)))
  1340. X        (newline)
  1341. X        ); ngorp
  1342. X      ); fi
  1343. X      ); tel
  1344. X); defun tst-equ-log-string
  1345. X
  1346. X(defun tst-equ-log-atom (el1 el2)
  1347. X
  1348. X  (let ()
  1349. X
  1350. X    (if (not (equal el1 el2))
  1351. X      (progn  
  1352. X;        (debug nil "in atom" el1 el2)
  1353. X        (indent-to (* tst-equ-indent 4))
  1354. X        (insert (prin1-to-string (car el1))
  1355. X                "   " (prin1-to-string (cdr el1))
  1356. X                " " (prin1-to-string (cdr el2)))
  1357. X        (newline)
  1358. X        ); ngorp
  1359. X      ); fi
  1360. X      ); tel
  1361. X); defun tst-equ-log-atom
  1362. X
  1363. X(defun tst-equ-log-syntable (a1 a2)
  1364. X  " Outputs the differences between two syntax tables in the form:
  1365. X      element_number : value1  value2"
  1366. X
  1367. X  (let (e1 e2 index)
  1368. X;    (debug nil "In syntable" (car el1))
  1369. X    (if (not (equal a1 a2))
  1370. X          (while (not (= index 256))
  1371. X            (setq e1 (aref a1 index))
  1372. X            (setq e2 (aref a2 index))
  1373. X            (if (not (equal e1 e2))
  1374. X                (progn
  1375. X                  (indent-to (* tst-equ-indent 4))
  1376. X                  (insert (prin1-to-string index) ": "
  1377. X                    (prin1-to-string e1) " " (prin1-to-string e2))
  1378. X                  (newline)
  1379. X                  );ngorp
  1380. X              ); fi
  1381. X            (+1 index)
  1382. X            ); elihw
  1383. X      ); fi
  1384. X          ); tel
  1385. X); defun tst-equ-log-syntable
  1386. X
  1387. X
  1388. X
  1389. X(defun tst-equ-log-keymap (a1 a2)
  1390. X  " Outputs only the fact that two keymaps do not match.  Has the potential
  1391. X     for future enhancements (like, describing which keys don't match"
  1392. X
  1393. X;  (debug nil "in keymap" (car el1))
  1394. X  (if (not (equal a1 a2))
  1395. X      (progn
  1396. X        (indent-to (* tst-equ-indent 4))
  1397. X        (insert (prin1-to-string (car a1)))
  1398. X        ); ngorp
  1399. X    );fi
  1400. X); defun tst-equ-log-keymap
  1401. X;  (let (e1 e2 index)
  1402. X;          (while (not (= index 256))
  1403. X;            (setq e1 (aref a1 index))
  1404. X;            (setq e2 (aref a2 index))
  1405. X;            (if (not (equal e1 e2))
  1406. X;                (progn
  1407. X;                  (indent-to (* tst-equ-indent 4))
  1408. X;                  (insert (prin1-to-string index) ": "
  1409. X;                    (prin1-to-string e1) " " (prin1-to-string e2))
  1410. X;                  (newline)
  1411. X;                  );ngorp
  1412. X;              ); fi
  1413. X;            (+1 index)
  1414. X;            ); elihw
  1415. X;
  1416. X;          ); tel
  1417. X;); defun tst-equ-log-syntable
  1418. X
  1419. X
  1420. X
  1421. X(defun tst-equ-log-diff (equal-flag  v1 v2)
  1422. X  "Logs differences in *equal-log* buffer. "
  1423. X
  1424. X
  1425. X  (let ()
  1426. X      (if (or tst-equ-log-all-compares (not equal-flag))
  1427. X          (progn
  1428. X            (indent-to (* tst-equ-indent 4))
  1429. X            (insert (prin1-to-string v1) " " (prin1-to-string v2))
  1430. X            (newline)
  1431. X            ); ngorp
  1432. X        );fi
  1433. X
  1434. X  ) ; let
  1435. X) ; defun tst-equ-log-diff
  1436. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1437. X
  1438. X(defun tst-equ-log-diff-line (line1 line2)
  1439. X  "Logs differences in *equal-log* buffer. "
  1440. X
  1441. X
  1442. X  (let ()
  1443. X
  1444. X      (goto-char (point-max))
  1445. X      (newline)
  1446. X      (indent-to (* tst-equ-indent 4))
  1447. X      (insert "1: " line1)
  1448. X      (newline)
  1449. X      (indent-to (* tst-equ-indent 4))
  1450. X      (insert "2: " line2)
  1451. X      (newline)
  1452. X
  1453. X  ) ; let
  1454. X) ; defun tst-equ-log-diff-line
  1455. X
  1456. X
  1457. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1458. X
  1459. X(defun tst-equ-find-buffer-with-name (state name )
  1460. X    "Return a buff-state of the buffer from STATE with name NAME."
  1461. X
  1462. X; Variables
  1463. X
  1464. X  (let  (buffers buff-state buff-name found)
  1465. X
  1466. X    (setq found nil)
  1467. X    (setq buffers (cadr (assoc 'buffers state)))
  1468. X
  1469. X
  1470. X    (while (not found)
  1471. X      (progn
  1472. X    (setq buff-state (car buffers))
  1473. X    (setq buffers (cdr buffers))
  1474. X    (setq buff-name (cadr (assoc 'buf-state-name buff-state)))
  1475. X    (if (equal buff-name name) 
  1476. X        (setq found t)
  1477. X    ; else
  1478. X        (progn 
  1479. X          (if (not buffers) 
  1480. X          (progn 
  1481. X            (setq found t)
  1482. X            (setq buff-state nil)
  1483. X            ); progn
  1484. X         ); fi
  1485. X        ); ngrop
  1486. X      ); if
  1487. X    ); progn
  1488. X      ); while
  1489. X    buff-state
  1490. X  ) ; let
  1491. X) ; defun tst-equ-find-buffer-with-name
  1492. X
  1493. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1494. X
  1495. X(defun tst-equ-named-buff-states (state1 name1 state2 name2)
  1496. X  " Compares, from STATE1, the state of the buffer who's name is
  1497. X    NAME1 with, from STATE2,  the state of the buffer who's name
  1498. X    is NAME2. If STATE2 is nil, then a buffer of NAME2 is expected
  1499. X    in STATE1. "
  1500. X
  1501. X  (interactive "P")
  1502. X                       
  1503. X; Variables
  1504. X
  1505. X  (let  (buff-state-1 buff-state-2)
  1506. X
  1507. X    ; first locate the buffers
  1508. X    (setq buff-state-1 (tst-equ-find-buffer-with-name state1 name1))
  1509. X    (if state2
  1510. X    (setq buff-state-2 (tst-equ-find-buffer-with-name state2 name2))
  1511. X    ; else
  1512. X    (setq buff-state-2 (tst-equ-find-buffer-with-name state1 name2))
  1513. X    ) ; if
  1514. X    (tst-equ-buffer-state buff-state-1 buff-state-2)
  1515. X
  1516. X  ) ; let
  1517. X) ; defun tst-equ-named-buff-states
  1518. X
  1519. X(defun tst-equ-local-vars (b1  b2)
  1520. X   " Compares the values of the local variables in two buffers and
  1521. X     logs the ones that are different."
  1522. X
  1523. X     
  1524. X   (interactive "P")
  1525. X
  1526. X   (let (vars1 vars2 var1 var2 tst-equ-result firsttime)
  1527. X
  1528. X    (setq tst-equ-result t)            ;default to "all equal "
  1529. X    (setq firsttime nil)                ;still just my first time ...
  1530. X
  1531. X
  1532. X     (setq vars1 (cadr (assoc 'buf-state-local-vars b1)))
  1533. X
  1534. X     (setq vars2 (cadr (assoc 'buf-state-local-vars b2)))
  1535. X
  1536. X     (while vars1                        ;go through the b1 vars first.
  1537. X       (setq var1 (car vars1))          ;get the next variable
  1538. X       (setq vars1 (cdr vars1))            ;.. and set the list to the tail
  1539. X       (setq var2 (assoc (car var1) vars2)) ; find this variable in b2
  1540. X       (if var2
  1541. X           (progn
  1542. X             (if (not (equal var1 var2))
  1543. X                 (progn
  1544. X                   (if (not firsttime)
  1545. X                       (progn
  1546. X                         (indent-to (* tst-equ-indent 3))
  1547. X                         (insert "local variables not equal ")
  1548. X                         (newline)
  1549. X                         (setq firsttime t)
  1550. X                         ); ngorp
  1551. X                     ); fi
  1552. X                   (setq tst-equ-result nil)
  1553. X                   (indent-to (* tst-equ-indent 4))
  1554. X                   (insert (prin1-to-string (car var1))
  1555. X                    "   " (prin1-to-string (cdr var1))
  1556. X                    " " (prin1-to-string (cdr var2)))
  1557. X                   (newline)
  1558. X                   ); ngorp
  1559. X         );fi
  1560. X       ); ngorp
  1561. X         ; else
  1562. X         (progn
  1563. X           (setq tst-equ-result nil)
  1564. X           (if (not firsttime)
  1565. X               (progn
  1566. X                 (insert "?")
  1567. X                 (indent-to (* tst-equ-level 3))
  1568. X                 (insert "local variables not equal ")
  1569. X                 (newline)
  1570. X                 (setq firsttime t)
  1571. X                 ); ngorp
  1572. X             ); fi
  1573. X           (indent-to (* tst-equ-level 4))
  1574. X           (insert  (prin1-to-string (car var1)) "not found in second buffer ")
  1575. X           (newline)
  1576. X           ); ngorp (of else)
  1577. X         ); fi [if vars2]
  1578. X       ); elihw
  1579. X
  1580. X     (setq vars1 (cadr (assoc 'buf-state-local-vars b1)))
  1581. X     (while vars2
  1582. X       
  1583. X       (setq var2 (car vars2))          ;get the next variable
  1584. X       (setq vars2 (cdr vars2))            ;.. and set the list to the tail
  1585. X       (setq var1 (assoc (car var2) vars1))
  1586. X       (if (not var1)
  1587. X         (progn
  1588. X           (setq tst-equ-result nil)
  1589. X           (if (not firsttime)
  1590. X               (progn
  1591. X                 (indent-to (* tst-equ-indent 4))
  1592. X                 (insert "local variables not equal:")
  1593. X                 (newline)
  1594. X                 (setq firsttime t)
  1595. X                 ); ngorp
  1596. X             ); fi
  1597. X           (indent-to (* tst-equ-indent 4))
  1598. X           (insert (prin1-to-string (car var2)) " not found in first buffer " )
  1599. X           (newline)
  1600. X           ); ngorp (of else)
  1601. X         ); fi 
  1602. X       ); elihw
  1603. X     (if tst-equ-result
  1604. X         (progn
  1605. X           (indent-to (* tst-equ-indent 4))
  1606. X           (insert "local variables are equal ")
  1607. X           (newline)
  1608. X           ); ngorp
  1609. X       ); fi
  1610. X     tst-equ-result                                ;return the tst-equ-result
  1611. X     ); tel
  1612. X   ); defun tst-equ-local-vars
  1613. X
  1614. X
  1615. X
  1616. SHAR_EOF
  1617. if test 32129 -ne "`wc -c < 'tst-equal.el'`"
  1618. then
  1619.     echo shar: "error transmitting 'tst-equal.el'" '(should have been 32129 characters)'
  1620. fi
  1621. fi
  1622. echo shar: "extracting 'tst-inequal.el'" '(3828 characters)'
  1623. if test -f 'tst-inequal.el'
  1624. then
  1625.     echo shar: "will not over-write existing file 'tst-inequal.el'"
  1626. else
  1627. sed 's/^X//' << \SHAR_EOF > 'tst-inequal.el'
  1628. X;;; inequal.el -- A number of inequality functions. 
  1629. X;;; See also equal.el
  1630. X;;; Lorri Menard, Wang Institute of Graduate Studies
  1631. X;;; Don Zaremba, Wang Institute of Graduate Studies
  1632. X;;; Copyright 1987 Wang Institute of Graduate Studies
  1633. X;;;
  1634. X
  1635. X(provide 'tst-inequal)
  1636. X
  1637. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1638. X
  1639. X(defun string-equal-less-white  (str1 str2)
  1640. X  " Returns t if the two strings are equal after ignoring whitespace."
  1641. X
  1642. X  (let  ()
  1643. X    (string-equal-less-regexp "\\s " str1 str2)
  1644. X  ) ; let
  1645. X) ; line-of-buffer
  1646. X
  1647. X
  1648. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1649. X
  1650. X(defun string-equal-less-regexp  (regexp str1 str2)
  1651. X  " Returns t if the two strings are equal after ignoring all substrings
  1652. X    that match regexp ."
  1653. X
  1654. X  (let  (start1 end1  start2 end2 token1 token2 success more1 more2)
  1655. X    (setq  success t more1 t more2 t)
  1656. X    (setq start1 (first-not-regexp regexp str1 0)); move to 1st non-white
  1657. X    (setq start2 (first-not-regexp regexp str2 0)); move to 1st non-white
  1658. X
  1659. X    (while (and more1 more2)
  1660. X      (progn
  1661. X     (setq end1 (string-match regexp str1 start1))
  1662. X     (setq end2 (string-match regexp str2 start2))
  1663. X     (if end1
  1664. X         (progn         ; end1 not nil 
  1665. X           (setq token1 (substring str1 start1 end1))
  1666. X           (setq start1 (first-not-regexp regexp str1 end1))
  1667. X           (if (not start1)  ; check for trailing delimiter only
  1668. X           (setq more1 nil))
  1669. X           ); progn
  1670. X          ;else
  1671. X         (progn
  1672. X           (setq token1 (substring str1 start1 nil));
  1673. X           (setq more1 nil)
  1674. X           ); progn
  1675. X     ); if
  1676. X     (if end2
  1677. X         (progn         ; end2 not nil 
  1678. X           (setq token2 (substring str2 start2 end2))
  1679. X           (setq start2 (first-not-regexp regexp str2 end2))
  1680. X           (if (not start2)  ; check for trailing delimiter only
  1681. X           (setq more2 nil))
  1682. X           ); progn
  1683. X          ;else
  1684. X         (progn
  1685. X           (setq token2 (substring str2 start2 nil));
  1686. X           (setq more2 nil)
  1687. X           ); progn
  1688. X     ); if
  1689. X;      (send-string-to-terminal "[")
  1690. X;        (send-string-to-terminal token1)
  1691. X;        (send-string-to-terminal "][")
  1692. X;        (send-string-to-terminal token2)
  1693. X;        (send-string-to-terminal "]")
  1694. X     (setq success (string-equal token1 token2))
  1695. X     (if (not success)
  1696. X         (setq more1 nil)) ; if failed then stop the loop
  1697. X      ); progn
  1698. X    ) ; while
  1699. X    (and (not more1) (not more2) success)
  1700. X  ) ; let
  1701. X) ; string-equal-less-white
  1702. X
  1703. X
  1704. X;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  1705. X
  1706. X(defun first-not-regexp (regexp str sindex)
  1707. X  " Returns the index of the first char in string that does not match
  1708. X    regular expression. Returns nil if nothing doesn't match."
  1709. X
  1710. X  (let  (fm more string-is-nil)
  1711. X    (setq more t slen)
  1712. X    (setq slen (length str))
  1713. X    (if (equal 0 slen) ; test for a zero length string
  1714. X    nil
  1715. X    ; else
  1716. X        (progn
  1717. X      (setq string-is-nil nil)
  1718. X      (setq fm (string-match regexp str sindex)) ; start of match
  1719. X      (if (or (not fm) (< sindex fm)) (setq more nil)) ; found non-regexp
  1720. X;      (debug nil "Before while" fm sindex)
  1721. X      (while more
  1722. X        (progn
  1723. X          (setq sindex (match-end 0))
  1724. X          (if (>= sindex slen) 
  1725. X          (progn
  1726. X            (setq string-is-nil t)
  1727. X            (setq more nil)
  1728. X            )
  1729. X        ;else
  1730. X        (progn
  1731. X          (setq fm (string-match regexp str sindex))
  1732. X          (if (or (not fm) (< sindex fm)) (setq more nil))
  1733. X;          (debug nil "In while " fm sindex)
  1734. X        ); progn
  1735. X        ); if
  1736. X        ); progn
  1737. X      ); while
  1738. X      (if string-is-nil nil sindex)
  1739. X     ); progn
  1740. X    ); if
  1741. X  ) ; let
  1742. X) ; first-not-regexp
  1743. X
  1744. X
  1745. X
  1746. X
  1747. X; example hook usage
  1748. X;
  1749. X; (setq tst-equ-line-hook 'first-5)
  1750. X; (setq tst-equ-mark-hook 'great-mark)
  1751. X;
  1752. X; example line hook - only compares first 5 chars on a line
  1753. X;(defun first-5 ()
  1754. X;    (string-equal (substring tst-equ-line1 0 5) (substring tst-equ-line2 0 5))
  1755. X;)
  1756. X
  1757. X;example mark hook - only concerned with relative order of marks
  1758. X;(defun great-mark ()
  1759. X;    (> tst-equ-mark1 tst-equ-mark2)
  1760. X; )
  1761. X
  1762. X
  1763. X
  1764. SHAR_EOF
  1765. if test 3828 -ne "`wc -c < 'tst-inequal.el'`"
  1766. then
  1767.     echo shar: "error transmitting 'tst-inequal.el'" '(should have been 3828 characters)'
  1768. fi
  1769. fi
  1770. echo shar: "extracting 'tst-instrument.el'" '(5937 characters)'
  1771. if test -f 'tst-instrument.el'
  1772. then
  1773.     echo shar: "will not over-write existing file 'tst-instrument.el'"
  1774. else
  1775. sed 's/^X//' << \SHAR_EOF > 'tst-instrument.el'
  1776. X;;; tst-instrument
  1777. X;;; Copyright 1987 Richard Rosenthal
  1778. X;;; All rights reserved.
  1779. X
  1780. X(provide 'tst-instrument)
  1781. X(require 'tst-annotate)
  1782. X
  1783. X(defvar *tst-last-instrumented-line* 0
  1784. X  "Defined in instrument.el.  Used in the following functions:
  1785. X     tst-instrument-defun
  1786. X     tst-instrument-primitive")
  1787. X
  1788. X(defun tst-instrument ()
  1789. X  "The tst-instrument function creates a buffer containing a copy of
  1790. Xthe buffer in which the function was invoked.  All code in the copied
  1791. Xbuffer is then instrumented and compiled.  We are talking about
  1792. Xcompiling LISP code."
  1793. X  (interactive)
  1794. X  (let* ((old-buffer (buffer-name))
  1795. X     (instrumented-buffer
  1796. X      (get-buffer-create (concat old-buffer "-instrumented"))))
  1797. X    (save-excursion
  1798. X      (set-buffer instrumented-buffer)
  1799. X      (emacs-lisp-mode)
  1800. X      (erase-buffer)
  1801. X      (insert-buffer old-buffer)
  1802. X      (tst-ann-set-db nil)
  1803. X      (tst-instrument-region (point-min) (point-max))
  1804. X      (eval-current-buffer)
  1805. X      (message "Done"))))
  1806. X
  1807. X
  1808. X(defun tst-instrument-region (start end)
  1809. X  (interactive "r")
  1810. X  (save-restriction
  1811. X    (narrow-to-region start end)
  1812. X    (goto-char (point-min))
  1813. X    (or (looking-at "\\s( *defun\\b") (beginning-of-next-defun))
  1814. X    (while (< (point) (point-max))
  1815. X      (tst-instrument-defun)
  1816. X      (beginning-of-next-defun))))
  1817. X
  1818. X
  1819. X(defun tst-instrument-defun ()
  1820. X  (save-excursion
  1821. X    (save-restriction
  1822. X      (push-mark (point) 'nomsg)
  1823. X      (setq *tst-last-instrumented-line* (line-number))
  1824. X      (if (error-occurred (forward-sexp 1))
  1825. X      (progn
  1826. X        (goto-char (point-max))
  1827. X        nil)
  1828. X    (narrow-to-region (mark) (point))
  1829. X    (goto-char (point-min))
  1830. X    (down-list 1)
  1831. X    (next-sexp)            ;looking at defun
  1832. X    (beginning-of-next-sexp)    ;looking at function name
  1833. X    (let ((start (point))
  1834. X          end)
  1835. X      (forward-sexp 1)
  1836. X      (setq end (point))
  1837. X      (backward-sexp 1)
  1838. X      (message "Instrumenting (defun %s..." (buffer-substring start end))
  1839. X      )
  1840. X    (beginning-of-next-sexp)    ;looking at parameter list
  1841. X    (beginning-of-next-sexp)    ;looking at comment?
  1842. X    (if (looking-at "\\s\"")
  1843. X        (beginning-of-next-sexp))    ;looking at parameter list
  1844. X
  1845. X    ;; now looking at first statement in defun
  1846. X    (while (< (point) (point-max))
  1847. X      (cond
  1848. X       ((looking-at "\\s(")
  1849. X        (tst-instrument-function))
  1850. X
  1851. X       ;;inside a comment
  1852. X       ((nth 4 (parse-partial-sexp (point-min) (point) nil nil nil))
  1853. X        (end-of-line)
  1854. X        (next-sexp))
  1855. X
  1856. X       (t
  1857. X        (beginning-of-next-sexp))))
  1858. X    t))))
  1859. X
  1860. X
  1861. X(defun tst-instrument-function ()
  1862. X;;;at this point, I was definitly looking at a left "(".
  1863. X  (cond
  1864. X   ((tst-looking-at-prohibited-form-p)
  1865. X    (beginning-of-next-sexp))        ;do nothing, skip it
  1866. X
  1867. X   ((tst-looking-at-special-form-p)
  1868. X    (tst-instrument-primitive)        ;instrument around it
  1869. X    (tst-instrument-special-form))    ;try to go in it
  1870. X
  1871. X   (t
  1872. X    (tst-instrument-primitive)        ;instrument around it
  1873. X      (down-list 1))))            ;go in it
  1874. X
  1875. X(defun tst-looking-at-prohibited-form-p ()
  1876. X  (cond
  1877. X   ((looking-at "\\s( *interactive\\b") t)
  1878. X   ((looking-at "\\s( *quote\\b") t)
  1879. X   ((looking-at "\\s'\\s(") t)
  1880. X   (t nil)))
  1881. X
  1882. X(defun tst-looking-at-special-form-p ()
  1883. X  "List potential trouble makers in this function"
  1884. X  (cond
  1885. X   ((looking-at "\\s( *cond\\b") t)
  1886. X   ((looking-at "\\s( *function\\b") t)
  1887. X   ((looking-at "\\s( *let\\b") t)
  1888. X   ((looking-at "\\s( *progn\\b") t)
  1889. X   (t nil)))
  1890. X
  1891. X(defun tst-instrument-special-form ()
  1892. X  "Explain how to deal with known trouble makers in this function"
  1893. X  (cond
  1894. X   ((looking-at "\\s( *let\\b")        ;minor problem
  1895. X    (tst-instrument-let))
  1896. X   ((looking-at "\\s( *progn\\b")    ;no problem
  1897. X    (down-list 1))
  1898. X   (t                    ;skip forms I don't know about
  1899. X    (beginning-of-next-sexp))))
  1900. X
  1901. X(defun tst-instrument-primitive ()
  1902. X  (let ((start (line-number)))
  1903. X    (if (> start *tst-last-instrumented-line*)
  1904. X    (progn
  1905. X      (setq *tst-last-instrumented-line* start)
  1906. X      (insert "(tst-cover " (int-to-string start) " ")
  1907. X      (forward-sexp 1)
  1908. X      (insert ")")
  1909. X      (backward-char 1)
  1910. X      (backward-sexp 1)
  1911. X      (tst-ann-append start 'count '(0))))))
  1912. X
  1913. X
  1914. X(defun tst-instrument-let ()
  1915. X  (down-list 1)
  1916. X  (next-sexp)                ;looking at let
  1917. X  (beginning-of-next-sexp)        ;looking at parameter list
  1918. X  (forward-sexp 1)            ;skip parameters for now
  1919. X  (next-sexp))
  1920. X
  1921. X
  1922. X;;;----------------------------------------------------------------------------
  1923. X(defun tst-cover (id arg)
  1924. X  "Version 2:  for testing, display arg in mini-buffer while
  1925. Xmoving cursor around buffer"
  1926. X  (save-excursion
  1927. X    (goto-line id)
  1928. X    (re-search-forward "\\s(")
  1929. X    (message "function returns %s" (prin1-to-string arg))
  1930. X    (sit-for 2)
  1931. X    )
  1932. X  arg)
  1933. X
  1934. X(defun tst-cover (id arg)
  1935. X  "Version 1:  for testing, display id and arg in mini-buffer"
  1936. X  (message "tst-cover %d %s" id (prin1-to-string arg))
  1937. X  (sit-for 0)
  1938. X  arg)
  1939. X
  1940. X(defun tst-cover (id arg)
  1941. X  "Version 0:  for testing, does nothing"
  1942. X  arg)
  1943. X
  1944. X(defun tst-cover (id arg)
  1945. X  "The Real Thing:  uses annotation capabilities"
  1946. X  (tst-ann-inc id 'count)
  1947. X  (tst-ann-append id 'values (list arg))
  1948. X  arg)
  1949. X
  1950. X
  1951. X;;;============================================================================
  1952. X(defun beginning-of-next-defun ()
  1953. X  "This function finds LISP defun"
  1954. X  (if (= (point) (point-max))
  1955. X      nil
  1956. X    (forward-char 1)
  1957. X    (and (re-search-forward "\\s( *defun\\b" nil 'move 1)
  1958. X     (re-search-backward "\\s("))))
  1959. X
  1960. X(defmacro error-occurred (&rest body)
  1961. X  "As defined in mlsupport.el"
  1962. X  (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
  1963. X
  1964. X(defun line-number ()
  1965. X  "Return line number of current line.  Gives consistent results."
  1966. X  (count-lines-correctly 1 (point)))
  1967. X
  1968. X(defun count-lines-correctly (start end)
  1969. X  "Return number of newlines between START and END.  Gives
  1970. Xconsistent results."
  1971. X  (save-excursion
  1972. X    (save-restriction
  1973. X      (goto-char end)
  1974. X      (end-of-line)
  1975. X      (narrow-to-region start (point))
  1976. X      (goto-char (point-min))
  1977. X      (- (buffer-size) (forward-line (buffer-size))))))
  1978. X
  1979. X(defun next-sexp ()
  1980. X  (while (error-occurred (forward-sexp))
  1981. X    (forward-char 1))
  1982. X  (or (= (point) (point-max)) (backward-sexp)))
  1983. X
  1984. X(defun beginning-of-next-sexp ()
  1985. X  (forward-sexp 1)
  1986. X  (next-sexp))
  1987. SHAR_EOF
  1988. if test 5937 -ne "`wc -c < 'tst-instrument.el'`"
  1989. then
  1990.     echo shar: "error transmitting 'tst-instrument.el'" '(should have been 5937 characters)'
  1991. fi
  1992. fi
  1993. exit 0
  1994. #    End of shell archive
  1995.  
  1996.  
  1997. -- 
  1998.  
  1999. Rich $alz
  2000. Cronus Project, BBN Labs            rsalz@bbn.com
  2001. Moderator, comp.sources.unix            sources@uunet.uu.net
  2002.